home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / devices.el.z / devices.el
Encoding:
Text File  |  1998-05-21  |  11.9 KB  |  343 lines
  1. ;;; devices.el -- XEmacs device API emulation
  2. ;; Author: wmperry
  3. ;; Created: 1997/10/17 14:07:54
  4. ;; Version: 1.6
  5. ;; Keywords: 
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. ;; This is a complete implementation of all the device-* functions found in
  31. ;; XEmacs 19.14.  A 'device' for Emacs 19 is just a frame, from which we can
  32. ;; determine the connection to an X display, etc.
  33.  
  34. (require 'cl)
  35. (eval-when-compile
  36.   (if (string-match "XEmacs" (emacs-version))
  37.       (set 'byte-optimize nil)))
  38.     
  39. (if (string-match "XEmacs" (emacs-version))
  40.     nil
  41. '()
  42. (defalias 'selected-device 'ignore)
  43. (defalias 'device-or-frame-p 'framep)
  44. (defalias 'device-console 'ignore)
  45. (defalias 'device-sound-enabled-p 'ignore)
  46. (defalias 'device-live-p 'frame-live-p)
  47. (defalias 'devicep 'framep)
  48. (defalias 'frame-device 'identity)
  49. (defalias 'redisplay-device 'redraw-frame)
  50. (defalias 'redraw-device 'redraw-frame)
  51. (defalias 'select-device 'select-frame)
  52. (defalias 'set-device-class 'ignore)
  53.  
  54. (defun make-device (type connection &optional props)
  55.   "Create a new device of type TYPE, attached to connection CONNECTION.
  56.  
  57. The valid values for CONNECTION are device-specific; however,
  58. CONNECTION is generally a string. (Specifically, for X devices,
  59. CONNECTION should be a display specification such as \"foo:0\", and
  60. for TTY devices, CONNECTION should be the filename of a TTY device
  61. file, such as \"/dev/ttyp4\", or nil to refer to XEmacs' standard
  62. input/output.)
  63.  
  64. PROPS, if specified, should be a plist of properties controlling
  65. device creation.
  66.  
  67. If CONNECTION specifies an already-existing device connection, that
  68. device is simply returned; no new device is created, and PROPS
  69. have no effect."
  70.   (cond
  71.    ((and (eq type 'x) connection)
  72.     (make-frame-on-display connection props))
  73.    ((eq type 'x)
  74.     (make-frame props))
  75.    ((eq type 'tty)
  76.     nil)
  77.    (t
  78.     (error "Unsupported device-type: %s" type))))
  79.  
  80. (defun make-frame-on-device (type connection &optional props)
  81.   "Create a frame of type TYPE on CONNECTION.
  82. TYPE should be a symbol naming the device type, i.e. one of
  83.  
  84. x    An X display.  CONNECTION should be a standard display string
  85.     such as \"unix:0\", or nil for the display specified on the
  86.     command line or in the DISPLAY environment variable.  Only if
  87.     support for X was compiled into    XEmacs.
  88. tty    A standard TTY connection or terminal.  CONNECTION should be
  89.     a TTY device name such as \"/dev/ttyp2\" (as determined by
  90.     the Unix command `tty') or nil for XEmacs' standard input
  91.     and output (usually the TTY in which XEmacs started).  Only
  92.     if support for TTY's was compiled into XEmacs.
  93. ns    A connection to a machine running the NeXTstep windowing
  94.     system.  Not currently implemented.
  95. win32    A connection to a machine running Microsoft Windows NT or
  96.     Windows 95.  Not currently implemented.
  97. pc    A direct-write MS-DOS frame.  Not currently implemented.
  98.  
  99. PROPS should be an plist of properties, as in the call to `make-frame'.
  100.  
  101. If a connection to CONNECTION already exists, it is reused; otherwise,
  102. a new connection is opened."
  103.   (make-device type connection props))
  104.  
  105. (defun make-tty-device (&optional tty terminal-type)
  106.   "Create a new device on TTY.
  107.   TTY should be the name of a tty device file (e.g. \"/dev/ttyp3\" under
  108. SunOS et al.), as returned by the `tty' command.  A value of nil means
  109. use the stdin and stdout as passed to XEmacs from the shell.
  110.   If TERMINAL-TYPE is non-nil, it should be a string specifying the
  111. type of the terminal attached to the specified tty.  If it is nil,
  112. the terminal type will be inferred from the TERM environment variable."
  113.   (make-device 'tty tty (list 'terminal-type terminal-type)))
  114.  
  115. (defun make-x-device (&optional display)
  116.   (make-device 'x display))
  117.  
  118. (defun set-device-selected-frame (device frame)
  119.   "Set the selected frame of device object DEVICE to FRAME.
  120. If DEVICE is nil, the selected device is used.
  121. If DEVICE is the selected device, this makes FRAME the selected frame."
  122.   (select-frame frame))
  123.  
  124. (defun set-device-baud-rate (device rate)
  125.   "Set the output baud rate of DEVICE to RATE.
  126. On most systems, changing this value will affect the amount of padding
  127. and other strategic decisions made during redisplay."
  128.   (setq baud-rate rate))
  129.  
  130. (defun dfw-device (obj)
  131.   "Given a device, frame, or window, return the associated device.
  132. Return nil otherwise."
  133.   (cond
  134.    ((windowp obj)
  135.     (window-frame obj))
  136.    ((framep obj)
  137.     obj)
  138.    (t
  139.     nil)))
  140.  
  141. (defun event-device (event)
  142.   "Return the device that EVENT occurred on.
  143. This will be nil for some types of events (e.g. keyboard and eval events)."
  144.   (dfw-device (posn-window (event-start event))))
  145.  
  146. (defun device-connection (&optional device)
  147.   "Return the connection of the specified device.
  148. DEVICE defaults to the selected device if omitted"
  149.   (or (cdr-safe (assq 'display (frame-parameters device))) "stdio"))
  150.  
  151. (defun find-device (connection &optional type)
  152.   "Look for an existing device attached to connection CONNECTION.
  153. Return the device if found; otherwise, return nil.
  154.  
  155. If TYPE is specified, only return devices of that type; otherwise,
  156. return devices of any type. (It is possible, although unlikely,
  157. that two devices of different types could have the same connection
  158. name; in such a case, the first device found is returned.)"
  159.   (let ((devices (device-list))
  160.     (retval nil))
  161.     (while (and devices (not nil))
  162.       (if (equal connection (device-connection (car devices)))
  163.       (setq retval (car devices)))
  164.       (setq devices (cdr devices)))
  165.     retval))
  166.  
  167. (defalias 'get-device 'find-device)
  168.  
  169. (defmacro device-baud-rate (&optional device)
  170.   "Return the output baud rate of DEVICE."
  171.   'baud-rate)
  172.  
  173. (defun device-on-window-system-p (&optional device)
  174.   "Return non-nil if DEVICE is on a window system.
  175. This generally means that there is support for the mouse, the menubar,
  176. the toolbar, glyphs, etc."
  177.   (and (cdr-safe (assq 'display (frame-parameters device))) t))
  178.  
  179. (defun device-name (&optional device)
  180.   "Return the name of the specified device."
  181.   (or (cdr-safe (assq 'display (frame-parameters device))) "stdio"))
  182.  
  183. (defun device-frame-list (&optional device)
  184.   "Return a list of all frames on DEVICE.
  185. If DEVICE is nil, the selected device will be used."
  186.   (let ((desired (device-connection device)))
  187.     (filtered-frame-list (function (lambda (x) (equal (device-connection x)
  188.                               desired))))))
  189. (defun device-list ()
  190.   "Return a list of all devices"
  191.   (let ((seen nil)
  192.     (cur nil)
  193.     (conn nil)
  194.     (retval nil)
  195.     (not-heard (frame-list)))
  196.     (while not-heard
  197.       (setq cur (car not-heard)
  198.         conn (device-connection cur)
  199.         not-heard (cdr not-heard))
  200.       (if (member conn seen)
  201.       nil                ; Already got it
  202.     (setq seen (cons conn seen)    ; Whoo hoo, a new one!
  203.           retval (cons cur retval))))
  204.     retval))
  205.  
  206. (defvar delete-device-hook nil
  207.   "Function or functions to call when a device is deleted.
  208. One argument, the to-be-deleted device.")
  209.  
  210. (defun delete-device (device &optional force)
  211.   "Delete DEVICE, permanently eliminating it from use.
  212. Normally, you cannot delete the last non-minibuffer-only frame (you must
  213. use `save-buffers-kill-emacs' or `kill-emacs').  However, if optional
  214. second argument FORCE is non-nil, you can delete the last frame. (This
  215. will automatically call `save-buffers-kill-emacs'.)"
  216.   (let ((frames (device-frame-list device)))
  217.     (run-hook-with-args 'delete-device-hook device)
  218.     (while frames
  219.       (delete-frame (car frames) force)
  220.       (setq frames (cdr frames)))))
  221.  
  222. (defun device-color-cells (&optional device)
  223.   (case window-system
  224.     ((x win32 w32 pm) (x-display-color-cells device))
  225.     (ns (ns-display-color-cells device))
  226.     (otherwise 1)))
  227.  
  228. (defun device-pixel-width (&optional device)
  229.   (case window-system
  230.     ((x win32 w32 pm) (x-display-pixel-width device))
  231.     (ns (ns-display-pixel-width device))
  232.     (otherwise (frame-width device))))
  233.  
  234. (defun device-pixel-height (&optional device)
  235.   (case window-system
  236.     ((x win32 w32 pm) (x-display-pixel-height device))
  237.     (ns (ns-display-pixel-height device))
  238.     (otherwise (frame-height device))))
  239.  
  240. (defun device-mm-width (&optional device)
  241.   (case window-system
  242.     ((x win32 w32 pm) (x-display-mm-width device))
  243.     (ns (ns-display-mm-width device))
  244.     (otherwise nil)))
  245.  
  246. (defun device-mm-height (&optional device)
  247.   (case window-system
  248.     ((x win32 w32 pm) (x-display-mm-height device))
  249.     (ns (ns-display-mm-height device))
  250.     (otherwise nil)))
  251.  
  252. (defun device-bitplanes (&optional device)
  253.   (case window-system
  254.     ((x win32 w32 pm) (x-display-planes device))
  255.     (ns (ns-display-planes device))
  256.     (otherwise 2)))
  257.  
  258. (defun device-class (&optional device)
  259.   (case window-system
  260.     (x                    ; X11
  261.      (cond
  262.       ((fboundp 'x-display-visual-class)
  263.        (let ((val (symbol-name (x-display-visual-class device))))
  264.      (cond
  265.       ((string-match "color" val) 'color)
  266.       ((string-match "gray-scale" val) 'grayscale)
  267.       (t 'mono))))
  268.       ((fboundp 'x-display-color-p)
  269.        (if (x-display-color-p device)
  270.        'color
  271.      'mono))
  272.       (t 'color)))
  273.     (pm                    ; OS/2 Presentation Manager
  274.      (cond
  275.       ((fboundp 'pm-display-visual-class)
  276.        (let ((val (symbol-name (pm-display-visual-class device))))
  277.      (cond
  278.       ((string-match "color" val) 'color)
  279.       ((string-match "gray-scale" val) 'grayscale)
  280.       (t 'mono))))
  281.       ((fboundp 'pm-display-color-p)
  282.        (if (pm-display-color-p device)
  283.        'color
  284.      'mono))
  285.       (t 'color)))
  286.     (ns
  287.      (cond
  288.       ((fboundp 'ns-display-visual-class)
  289.        (let ((val (symbol-name (ns-display-visual-class device))))
  290.      (cond
  291.       ((string-match "color" val) 'color)
  292.       ((string-match "gray-scale" val) 'grayscale)
  293.       (t 'mono))))
  294.       ((fboundp 'ns-display-color-p)
  295.        (if (ns-display-color-p device)
  296.        'color
  297.      'mono))
  298.       (t 'mono)))
  299.     (otherwise 'color)))
  300.  
  301. (defun device-class-list ()
  302.   "Returns a list of valid device classes."
  303.   (list 'color 'grayscale 'mono))
  304.  
  305. (defun valid-device-class-p (class)
  306.   "Given a CLASS, return t if it is valid.
  307. Valid classes are 'color, 'grayscale, and 'mono."
  308.   (memq class (device-class-list)))
  309.  
  310. (defun device-or-frame-type (device-or-frame)
  311.   "Return the type (e.g. `x' or `tty') of DEVICE-OR-FRAME.
  312. DEVICE-OR-FRAME should be a device or a frame object.  See `device-type'
  313. for a description of the possible types."
  314.   (or window-system 'tty))
  315.  
  316. (defun device-type (&optional device)
  317.   "Return the type of the specified device (e.g. `x' or `tty').
  318. Value is `tty' for a tty device (a character-only terminal),
  319. `x' for a device which is a connection to an X server,
  320. 'ns' for a device which is a connection to a NeXTStep dps server,
  321. 'win32' or 'w32' for a Windows-NT window,
  322. 'pm' for an OS/2 Presentation Manager window,
  323. 'intuition' for an Amiga screen"
  324.   (device-or-frame-type device))
  325.  
  326. (defun device-type-list ()
  327.   "Return a list of valid console types."
  328.   (if window-system
  329.       (list window-system 'tty)
  330.     (list 'tty)))
  331.  
  332. (defun valid-device-type-p (type)
  333.   "Given a TYPE, return t if it is valid."
  334.   (memq type (device-type-list)))
  335.  
  336. ) ; This closes the conditional on whether we are in XEmacs or not
  337.  
  338. (provide 'devices)
  339.  
  340. (eval-when-compile
  341.   (if (string-match "XEmacs" (emacs-version))
  342.       (set 'byte-optimize t)))
  343.